home *** CD-ROM | disk | FTP | other *** search
/ Collection of Internet / Collection of Internet.iso / protocol / standard / vga / whatvga.pas < prev    next >
Pascal/Delphi Source File  |  1993-07-14  |  25KB  |  1,007 lines
  1.  
  2. uses dos,crt,supervga;
  3.  
  4.  
  5. procedure setpix(x,y:word;col:longint);
  6. const
  7.   msk:array[0..7] of byte=(128,64,32,16,8,4,2,1);
  8.   plane :array[0..1] of byte=(5,10);
  9.   plane4:array[0..3] of byte=(1,2,4,8);
  10.   mscga4:array[0..3] of byte=($3f,$cf,$f3,$fc);
  11.   shcga4:array[0..3] of byte=(6,4,2,0);
  12. var l:longint;
  13.     m,z:word;
  14. begin
  15.   case memmode of
  16.    _cga2:begin
  17.            z:=(y shr 1)*bytes+(x shr 3);
  18.            if odd(y) then inc(z,8192);
  19.            mem[$b800:z]:=(mem[$b800:z] and (255 xor msk[x and 7]))
  20.                          or ((col and 1) shl (7-(x and 7)));
  21.          end;
  22.    _cga4:begin
  23.            z:=(y shr 1)*bytes+(x shr 2);
  24.            if odd(y) then inc(z,8192);
  25.            mem[$b800:z]:=(mem[$b800:z] and mscga4[x and 3])
  26.                          or (col and 3) shl shcga4[x and 3];
  27.          end;
  28.     _pl2:begin
  29.            l:=y*bytes+(x shr 3);
  30.            wrinx($3ce,3,0);
  31.            wrinx($3ce,5,2);
  32.            wrinx($3c4,2,1);
  33.            wrinx($3ce,8,msk[x and 7]);
  34.            setbank(l shr 16);
  35.            z:=mem[vseg:word(l)];
  36.            mem[vseg:word(l)]:=col;
  37.          end;
  38.    _pl2e:begin
  39.            l:=y*128+(x shr 3);
  40.            modinx($3ce,5,3,0);
  41.            wrinx($3c4,2,15);
  42.            wrinx($3ce,0,col*3);
  43.            wrinx($3ce,1,3);
  44.            wrinx($3ce,8,msk[x and 7]);
  45.            z:=mem[vseg:word(l)];
  46.            mem[vseg:word(l)]:=0;
  47.          end;
  48.     _pl4:begin
  49.            l:=y*bytes+(x shr 4);
  50.            wrinx($3ce,3,0);
  51.            wrinx($3ce,5,2);
  52.            wrinx($3c4,2,plane[(x shr 3) and 1]);
  53.            wrinx($3ce,8,msk[x and 7]);
  54.            setbank(l shr 16);
  55.            z:=mem[vseg:word(l)];
  56.            mem[vseg:word(l)]:=col;
  57.          end;
  58.     _pk4:begin
  59.            l:=y*bytes+(x shr 2);
  60.            setbank(l shr 16);
  61.            z:=mem[vseg:word(l)] and mscga4[x and 3];
  62.            mem[vseg:word(l)]:=z or (col shl shcga4[x and 3]);
  63.          end;
  64.    _pl16:begin
  65.            l:=y*bytes+(x shr 3);
  66.            wrinx($3ce,3,0);
  67.            wrinx($3ce,5,2);
  68.            wrinx($3ce,8,msk[x and 7]);
  69.            setbank(l shr 16);
  70.            z:=mem[vseg:word(l)];
  71.            mem[vseg:word(l)]:=col;
  72.          end;
  73.    _pk16:begin
  74.            l:=y*bytes+(x shr 1);
  75.            setbank(l shr 16);
  76.            z:=mem[vseg:word(l)];
  77.            if odd(x) then z:=z and $f+(col shl 4)
  78.                      else z:=z and $f0+col;
  79.            mem[vseg:word(l)]:=z;
  80.          end;
  81.    _p256:begin
  82.            l:=y*bytes+x;
  83.            setbank(l shr 16);
  84.            mem[vseg:word(l)]:=col;
  85.          end;
  86.    _p32k,_p64k:
  87.          begin
  88.            l:=y*bytes+(x shl 1);
  89.            setbank(l shr 16);
  90.            memw[vseg:word(l)]:=col;
  91.          end;
  92.    _p16m:begin
  93.            l:=y*bytes+(x*3);
  94.            z:=word(l);
  95.            m:=l shr 16;
  96.            setbank(m);
  97.            if z<$fffe then move(col,mem[vseg:z],3)
  98.            else begin
  99.              mem[vseg:z]:=lo(col);
  100.              if z=$ffff then setbank(m+1);
  101.              mem[vseg:z+1]:=lo(col shr 8);
  102.              if z=$fffe then setbank(m+1);
  103.              mem[vseg:z+2]:=col shr 16;
  104.            end;
  105.          end;
  106.     else ;
  107.   end;
  108. end;
  109.  
  110.  
  111. procedure setvstartxy(x,y:word);
  112. var l:longint;
  113. begin
  114.   l:=0;
  115.   case memmode of
  116.           _pl16:l:=(bytes*y+(x div 8))*4;
  117.           _p256:l:=bytes*y+x;
  118.     _p32k,_p64k:l:=bytes*y+x*2;
  119.           _p16m:l:=bytes*y+x*3;
  120.   end;
  121.   setvstart(l);
  122. end;
  123.  
  124.  
  125. function whitecol:longint;
  126. var col:longint;
  127. begin
  128.   case memmode of
  129.     _cga2,_pl2e,
  130.      _pl2:col:=1;
  131.     _cga4,_pk4
  132.     ,_pl4:col:=3;
  133.     _pk16,_pl16,
  134.     _p256:col:=15;
  135.     _p32k:col:=$7fff;
  136.     _p64k:col:=$ffff;
  137.     _p16m:col:=$ffffff;
  138.   else
  139.   end;
  140.   whitecol:=col;
  141. end;
  142.  
  143.  
  144. procedure wrtext(x,y:word;txt:string);      {write TXT to pos (X,Y)}
  145. type
  146.   pchar=array[char] of array[0..15] of byte;
  147. var
  148.   p:^pchar;
  149.   c:char;
  150.   i,j,z,b:integer;
  151.   ad,bk:word;
  152.   l,v,col:longint;
  153. begin
  154.   rp.bh:=6;
  155.   vio($1130);
  156.   case memmode of
  157.     _cga2,_pl2e,
  158.      _pl2:col:=1;
  159.     _cga4,_pk4
  160.     ,_pl4:col:=3;
  161.     _pk16,_pl16,
  162.     _p256:col:=15;
  163.     _p32k:col:=$7fff;
  164.     _p64k:col:=$ffff;
  165.     _p16m:col:=$ffffff;
  166.   else
  167.   end;
  168.   p:=ptr(rp.es,rp.bp);
  169.   for z:=1 to length(txt) do
  170.   begin
  171.     c:=txt[z];
  172.     for j:=0 to 15 do
  173.     begin
  174.       b:=p^[c][j];
  175.       for i:=0 to 7 do
  176.       begin
  177.         if (b and 128)<>0 then v:=col else v:=0;
  178.         setpix(x+i,y+j,v);
  179.         b:=b shl 1;
  180.       end;
  181.     end;
  182.     inc(x,8);
  183.   end;
  184. end;
  185.  
  186.  
  187. procedure drawtestpattern(nam:string);
  188.                        {Draw Test pattern.}
  189. var s:string;
  190.   l:longint;
  191.   x,y,yst:word;
  192.   white:longint;
  193.  
  194.   function rgb(r,g,b:word):longint;
  195.   begin
  196.     r:=lo(r);g:=lo(g);b:=lo(b);
  197.     case colbits[memmode] of
  198.        1:rgb:=r and 1;
  199.        2:rgb:=r and 3;
  200.        4:rgb:=r and 15;
  201.        8:rgb:=r;
  202.       15:rgb:=((r shr 3) shl 5+(g shr 3)) shl 5+(b shr 3);
  203.       16:rgb:=((r shr 3) shl 6+(g shr 2)) shl 5+(b shr 3);
  204.       24:rgb:=(longint(r) shl 8+g) shl 8 +b;
  205.     end;
  206.   end;
  207.  
  208.  
  209.   procedure wline(stx,sty,ex,ey:integer);
  210.   var x,y,d,mx,my:integer;
  211.      l:longint;
  212.   begin
  213.     if sty>ey then
  214.     begin
  215.       x:=stx;stx:=ex;ex:=x;
  216.       x:=sty;sty:=ey;ey:=x;
  217.     end;
  218.     y:=0;
  219.     mx:=abs(ex-stx);
  220.     my:=ey-sty;
  221.     d:=0;
  222.     repeat
  223.       l:=rgb(y,y,y);
  224.       y:=(y+1) and 255;
  225.       setpix(stx,sty,l);
  226.       if abs(d+mx)<abs(d-my) then
  227.       begin
  228.         inc(sty);
  229.         d:=d+mx;
  230.       end
  231.       else begin
  232.         d:=d-my;
  233.         if ex>stx then inc(stx)
  234.                   else dec(stx);
  235.       end;
  236.     until (stx=ex) and (sty=ey);
  237.  
  238.   end;
  239.  
  240. begin
  241.  
  242.   white:=whitecol;
  243.  
  244.   wline(50,30,pixels-50,30);
  245.   wline(50,lins-30,pixels-50,lins-30);
  246.  
  247.   wline(50,30,50,lins-30);
  248.   wline(pixels-50,30,pixels-50,lins-30);
  249.   wline(50,30,pixels-50,lins-30);
  250.  
  251.   wline(pixels-50,30,50,lins-30);
  252.  
  253.   if lins>200 then yst:=50 else yst:=10;
  254.   wrtext(10,yst,name+' with '+istr(mm)+' Kbytes.');
  255.   wrtext(10,yst+25,nam);
  256.  
  257.   for x:=1 to (pixels-10) div 100 do
  258.   begin
  259.     for y:=1 to 10 do
  260.       setpix(x*100,y,white);
  261.     wrtext(x*100+3,1,istr(x));
  262.   end;
  263.  
  264.   for x:=1 to (lins-10) div 100 do
  265.   begin
  266.     for y:=1 to 10 do
  267.       setpix(y,x*100,white);
  268.     wrtext(1,x*100+2,istr(x));
  269.   end;
  270.  
  271.   case memmode of
  272.      _pk4,
  273.      _pl4:for x:=0 to 63 do
  274.             for y:=0 to 63 do
  275.               setpix(30+x,yst+y+50,y shr 3);
  276.     _pk16,
  277.     _pl16:for x:=0 to 127 do
  278.             if lins<250 then
  279.               for y:=0 to 63 do
  280.                 setpix(30+x,yst+y+50,y shr 2)
  281.             else
  282.               for y:=0 to 127 do
  283.                 setpix(30+x,yst+y+50,y shr 3);
  284.     _p256:for x:=0 to 127 do
  285.             if lins<250 then
  286.               for y:=0 to 63 do
  287.                 setpix(30+x,yst+50+y,((y shl 2) and 240) +(x shr 3))
  288.             else
  289.               for y:=0 to 127 do
  290.                 setpix(30+x,yst+50+y,((y shl 1) and 240)+(x shr 3));
  291.  
  292.     _p32k,_p64k,_p16m:
  293.           if pixels<600 then
  294.           begin
  295.             for x:=0 to 63 do
  296.             begin
  297.               for y:=0 to 63 do
  298.               begin
  299.                 setpix(30+x,100+y,rgb(x*4,y*4,0));
  300.                 setpix(110+x,100+y,rgb(x*4,0,y*4));
  301.                 setpix(190+x,100+y,rgb(0,x*4,y*4));
  302.               end;
  303.             end;
  304.             for x:=0 to 255 do
  305.               for y:=170 to 179 do
  306.               begin
  307.                 setpix(x,y,rgb(x,0,0));
  308.                 setpix(x,y+10,rgb(0,x,0));
  309.                 setpix(x,y+20,rgb(0,0,x));
  310.               end;
  311.           end
  312.           else begin
  313.             for x:=0 to 127 do
  314.               for y:=0 to 127 do
  315.               begin
  316.                 setpix(30+x,120+y,rgb(x*2,y*2,0));
  317.                 setpix(200+x,120+y,rgb(x*2,0,y*2));
  318.                 setpix(370+x,120+y,rgb(0,x*2,y*2));
  319.               end;
  320.             for x:=0 to 511 do
  321.               for y:=260 to 269 do
  322.               begin
  323.                 setpix(x,y,rgb(x shr 1,0,0));
  324.                 setpix(x,y+10,rgb(0,x shr 1,0));
  325.                 setpix(x,y+20,rgb(0,0,x shr 1));
  326.               end;
  327.           end;
  328.  
  329.   end;
  330. end;
  331.  
  332.  
  333. procedure testvmode;
  334. begin
  335.   drawtestpattern('Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'+istr(lins)+' '
  336.      +istr(modecols[memmode])+' colors');
  337.   if readkey='' then;
  338.  
  339.   textmode(3);
  340. end;
  341.  
  342. procedure wrmono(s:string);
  343. var x:word;
  344. begin
  345.   for x:=1 to length(s) do
  346.     mem[$b000:x+x]:=ord(s[x]);
  347. end;
  348.  
  349. procedure testscrollmode;
  350. var s:string;
  351.   r13,sclins,scpixs:word;
  352.   x0,y0:integer;
  353.   ch:char;
  354. begin
  355.   sclins:=lins;
  356.   scpixs:=pixels;
  357.   s:='Mode: '+hex4(curmode)+'h: '+istr(pixels)+'x'+istr(lins)+' '+istr(modecols[memmode])+' colors';
  358.   r13:=rdinx(crtc,$13);
  359.   if (r13<128) and ((bytes*lins*planes*5 div 2)<mm*longint(1024)) then
  360.   begin
  361.     wrinx(crtc,$13,r13*2);
  362.     bytes:=bytes*2;
  363.     pixels:=pixels*2;
  364.   end;
  365.   lins:=mm*longint(1024) div (bytes*planes);
  366.  
  367.   for x0:=0 to (mm div 64)-1 do
  368.   begin
  369.     setbank(x0);
  370.     fillchar(mem[vseg:1],$ffff,0);
  371.     mem[vseg:0]:=0;
  372.   end;
  373.  
  374.   drawtestpattern(s);
  375.   x0:=0;
  376.   y0:=0;
  377.   repeat
  378.     setvstartxy(x0,y0);
  379.     wrmono(istr(x0)+':'+istr(y0)+'.');
  380.     ch:=readkey;
  381.     if ch=#0 then
  382.       case readkey of
  383.         #72:y0:=y0-16;
  384.         #75:x0:=x0-16;
  385.         #77:x0:=x0+16;
  386.         #80:y0:=y0+16;
  387.         #73:dec(y0);
  388.         #81:inc(y0);
  389.       end;
  390.     if x0<0 then x0:=0;
  391.     if y0<0 then y0:=0;
  392.     if x0>pixels-scpixs then x0:=pixels-scpixs;
  393.     if y0>lins-sclins then y0:=lins-sclins;
  394.  
  395.   until (ch=#27) or (ch=#13);
  396.  
  397.   textmode(3);
  398. end;
  399.  
  400.  
  401.  
  402.  
  403.  
  404.  
  405.  
  406. procedure testvgamodes;           {Test extended modes}
  407. var m:word;
  408.   md:integer;
  409.   c:char;
  410.  
  411. procedure tmode(m:word);
  412. begin
  413.   memmode:=modetbl[m].memmode;
  414.   pixels :=modetbl[m].xres;
  415.   lins   :=modetbl[m].yres;
  416.   bytes  :=modetbl[m].bytes;
  417.   if setmode(modetbl[m].md) then testvmode;
  418. end;
  419.  
  420. begin
  421.   textmode($103);
  422.   writeln('Modes:');
  423.   writeln;
  424.   for m:=1 to nomodes do
  425.   begin
  426.     writeln('  '+chr(m+64)+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  427.            +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  428.   end;
  429.   writeln;
  430.  
  431.   writeln('  *  All modes');
  432.  
  433.   writeln;
  434.   c:=upcase(readkey);
  435.   for m:=1 to nomodes do
  436.     if (c='*') or (c=chr(m+64)) then tmode(m);
  437.  
  438. end;
  439.  
  440. procedure teststdvgamodes;          {Test standard VGA modes}
  441. var m:word;
  442.   md:integer;
  443.   c:char;
  444.  
  445. procedure tmode(m:word);
  446. begin
  447.   memmode:=stdmodetbl[m].memmode;
  448.   pixels :=stdmodetbl[m].xres;
  449.   lins   :=stdmodetbl[m].yres;
  450.   bytes  :=stdmodetbl[m].bytes;
  451.   if setmode(stdmodetbl[m].md) then testvmode;
  452. end;
  453.  
  454. begin
  455.   textmode($103);
  456.   writeln('Modes:');
  457.   writeln;
  458.   for m:=1 to novgamodes do
  459.   begin
  460.     writeln('  '+chr(m+64)+' '+hex4(stdmodetbl[m].md)+'h '+istr(stdmodetbl[m].xres)
  461.            +'x'+istr(stdmodetbl[m].yres)+' '+mdtxt[stdmodetbl[m].memmode]);
  462.   end;
  463.   writeln;
  464.   writeln('  *  All modes');
  465.  
  466.   writeln;
  467.   c:=upcase(readkey);
  468.   for m:=1 to novgamodes do
  469.     if (c='*') or (c=chr(m+64)) then tmode(m);
  470.  
  471. end;
  472.  
  473.  
  474. procedure testscrollmodes;           {Test scrolling}
  475. var
  476.   m:word;
  477.   c:char;
  478.  
  479. procedure tmode(m:word);
  480. begin
  481.   memmode:=modetbl[m].memmode;
  482.   pixels :=modetbl[m].xres;
  483.   lins   :=modetbl[m].yres;
  484.   bytes  :=modetbl[m].bytes;
  485.   if setmode(modetbl[m].md) then testscrollmode;
  486. end;
  487.  
  488. begin
  489.   textmode($103);
  490.   writeln('Modes:');
  491.   writeln;
  492.   for m:=1 to nomodes do
  493.   begin
  494.     writeln('  '+chr(m+64)+' '+hex4(modetbl[m].md)+'h '+istr(modetbl[m].xres)
  495.            +'x'+istr(modetbl[m].yres)+' '+mdtxt[modetbl[m].memmode]);
  496.   end;
  497.   writeln;
  498.  
  499.   writeln('  *  All modes');
  500.  
  501.   writeln;
  502.   c:=upcase(readkey);
  503.   for m:=1 to nomodes do
  504.     if (c='*') or (c=chr(m+64)) then tmode(m);
  505.  
  506. end;
  507.  
  508. procedure searchformodes;      {Run through all possible modes
  509.                                 and try to id any new ones}
  510. type
  511.   regblk=record
  512.            base:word;
  513.            nbr:word;
  514.            x:array[0..255] of byte;
  515.          end;
  516. var
  517.   md,m,bseg,hig,wid,x,y,oldbytes,wordadr:word;
  518.   c:char;
  519.   ofil:text;
  520.   attregs:array[0..31] of byte;
  521.   seqregs,grcregs,crtcregs,xxregs:regblk;
  522.   stdregs:array[$3c0..$3df] of byte;
  523.   l:longint;
  524.   s:string;
  525.  
  526.  
  527. procedure dumprg(base:word;var rg:regblk);
  528. var six,ix:word;
  529. begin
  530.   rg.base:=base;
  531.   six:=inp(base);
  532.   outp(base,255);
  533.   ix:=inp(base);
  534.   if ix>127 then rg.nbr:=255
  535.   else if ix>63 then rg.nbr:=127
  536.   else if ix>31 then rg.nbr:=63
  537.   else if ix>15 then rg.nbr:=31
  538.   else if ix>7 then rg.nbr:=15
  539.   else rg.nbr:=7;
  540.   for ix:=0 to rg.nbr do
  541.     rg.x[ix]:=rdinx(base,ix);
  542.   outp(base,six);
  543. end;
  544.  
  545. procedure wrregs(var f:text;var rg:regblk);
  546. var x:word;
  547. begin
  548.   write(f,hex4(rg.base)+':');
  549.   for x:=0 to rg.nbr do
  550.   begin
  551.     if (x mod 25=0) and (x>0) then
  552.       write(f,'('+hex2(x)+'):');
  553.  
  554.     write(f,' '+hex2(rg.x[x]));
  555.   end;
  556.   writeln(f);
  557. end;
  558.  
  559. procedure dumpregs(var f:text);
  560. var x:word;
  561. begin
  562.   writeln(f,'Mode: '+hex2(md)+'h Pixels: '+istr(pixels)+' lines: '+istr(lins)
  563.        +' bytes: '+istr(bytes)+' colors: '+istr(modecols[memmode]));
  564.   writeln(f);
  565.   for x:=$3C0 to $3CF do write(' '+hex2(stdregs[x]));
  566.   writeln(f);
  567.   for x:=$3D0 to $3DF do write(' '+hex2(stdregs[x]));
  568.   writeln(f);
  569.   write(f,'03C0:');
  570.   for x:=0 to 31 do
  571.   begin
  572.     if x=25 then
  573.     begin
  574.       writeln(f);
  575.       write(f,'(19):');
  576.     end;
  577.     write(f,' '+hex2(attregs[x]));
  578.   end;
  579.   writeln(f);
  580.   wrregs(f,seqregs);
  581.   wrregs(f,grcregs);
  582.   wrregs(f,crtcregs);
  583.   if xxregs.base<>0 then wrregs(f,xxregs);
  584.   writeln(f);
  585. end;
  586.  
  587.  
  588.  
  589. procedure plotchar(x,y,ch:word);
  590. begin
  591.   mem[bseg:(y*wid+x) shl 1]:=ch;
  592. end;
  593.  
  594. procedure plotchat(x,y,ch,at:word);
  595. begin
  596.   memw[bseg:(y*wid+x) shl 1]:=at shl 8+ch;
  597. end;
  598.  
  599. procedure plotstr(x,y:word;s:string);
  600. var z:word;
  601. begin
  602.   for z:=1 to length(s) do
  603.     plotchar(x+z-1,y,ord(s[z]));
  604. end;
  605.  
  606. begin
  607.   for md:=$14 to $7f do
  608.   begin
  609.     textmode(3);
  610.     gotoxy(10,10);
  611.     write('Testing mode: '+hex2(md));
  612.     delay(500);
  613.     vio(md);
  614.     if mem[0:$449]=md then
  615.     begin
  616.       for x:=$3C2 to $3DF do stdregs[x]:=inp(x);
  617.       x:=inp($3DA);
  618.       stdregs[$3C0]:=inp($3C0);
  619.       for x:=0 to 31 do attregs[x]:=rdinx($3C0,x);
  620.       x:=rdinx($3C0,$30);
  621.       dumprg(crtc,crtcregs);
  622.       dumprg($3C4,seqregs);
  623.       dumprg($3CE,grcregs);
  624.       case chip of
  625.         __chips451,__chips452,__chips453:dumprg(crtc+2,xxregs);
  626.       else xxregs.base:=0;
  627.       end;
  628.       m:=grcregs.x[6];
  629.       case (m shr 2) and 3 of
  630.       0,1:bseg:=$a000;
  631.         2:bseg:=$b000;
  632.         3:bseg:=$b800;
  633.       end;
  634.       if odd(m) then
  635.       begin  {graf mode}
  636.         lins:=crtcregs.x[$12]+1;
  637.         x:=crtcregs.x[7];
  638.         if (x and 2)<>0 then inc(lins,256);
  639.         if (x and 64)<>0 then inc(lins,512);
  640.         pixels:=(crtcregs.x[1]+1)*8;
  641.  
  642.         wid:=crtcregs.x[$13];
  643.         wordadr:=2;
  644.         if (crtcregs.x[$14] and 64)<>0 then wordadr:=8
  645.         else if (crtcregs.x[$17] and 64)=0 then wordadr:=4;
  646.         case chip of
  647.          __p2000:if (grcregs.x[$13] and 64)<>0 then
  648.                  begin
  649.                    wordadr:=wordadr shr 1;
  650.                    if (grcregs.x[$21] and 32)<>0 then inc(wid,256);
  651.                  end;
  652.       __cirrus54:begin
  653.                    if (crtcregs.x[$1B] and 16)<>0 then inc(wid,256);
  654.                    if (crtcregs.x[$1A] and 1)<>0 then lins:=lins*2;
  655.                  end;
  656.         __tseng4:if (crtcregs.x[$3f] and 128)<>0 then inc(wid,256);
  657.         end;
  658.         x:=seqregs.x[4];
  659.         if (x and 8)<>0 then  {256 color}
  660.         begin
  661.           memmode:=_p256;
  662.           if dactype>_dac8 then
  663.           begin
  664.             dactocomm;
  665.             x:=inp($3c6);
  666.  
  667.             if x>127 then memmode:=_p32k;
  668.             case dactype of
  669.               _dac16:if (x and 64)<>0 then memmode:=_p64k;
  670.           (*  _dacss24:if x=$8e then
  671.                      begin
  672.                        memmode:=_p16m;
  673.                        pixels:=pixels*3;
  674.                      end;  *)
  675.              _dacatt:case (x and $60) of
  676.                        $40:memmode:=_p64k;
  677.                        $60:memmode:=_p16m;
  678.                      end;
  679.            _dacadac1:case x of
  680.                        $E1:memmode:=_p64k;
  681.                        $E5:memmode:=_p16m;
  682.                        $F0:memmode:=_p32k;
  683.                      end;
  684.             end;
  685.             dactopel;
  686.           end;
  687.         end
  688.        { else if (x and 4)<>0 then
  689.         begin
  690.           memmode:=_pl4;
  691.           bytes:=wid;
  692.         end }
  693.         else memmode:=_pl16;
  694.         bytes:=wid*wordadr;
  695.         case memmode of               {Adjust for HiColor}
  696.     _p32k,_p64k:pixels:=pixels div 2;
  697.           _p16m:pixels:=pixels div 3;
  698.         end;
  699.         if (pixels>800) and (pixels>=2*lins) then  {adjust for interlace}
  700.           lins:=lins*2;
  701.  
  702.         repeat
  703.           oldbytes:=bytes;
  704.  
  705.           if setmode(md) then
  706.           begin
  707.             case colbits[memmode] of
  708.               15:s:='32K';
  709.               16:s:='64K';
  710.               24:s:='16M';
  711.             else s:=istr(modecols[memmode]);
  712.             end;
  713.             drawtestpattern('Mode: '+hex2(md)+' ('+istr(pixels)+'x'+istr(lins)+' '
  714.                      +s+' col) '+istr(bytes)+' bytes.');
  715.           end;
  716.  
  717.           case readkey of
  718.            #0:begin
  719.                 c:=readkey;
  720.                 case c of
  721.                   #73:bytes:=bytes shl 1;
  722.                   #81:bytes:=bytes shr 1;
  723.                   #72:inc(bytes);
  724.                   #80:dec(bytes);
  725.                 end;
  726.               end;
  727.       'd','D':begin
  728.                 bytes:=oldbytes;
  729.                 textmode($103);
  730.                 dumpregs(output);
  731.                 if readkey='' then;
  732.               end;
  733.       'f','F':begin
  734.                 bytes:=oldbytes;
  735.                 assign(ofil,'register.vga');
  736.                 {$i-}
  737.                 append(ofil);
  738.                 {$i+}
  739.                 if ioresult<>0 then rewrite(ofil);
  740.                 dumpregs(ofil);
  741.                 close(ofil);
  742.               end;
  743.           end;
  744.         until bytes=oldbytes;
  745.       end
  746.       else begin {text mode}
  747.         for x:=0 to 16383 do
  748.           memw[bseg:x+x]:=$720;
  749.         wid:=memw[0:$44a];
  750.         for x:=0 to wid-1 do
  751.         begin
  752.           plotchar(x,0,(x mod 10)+ord('0'));
  753.           if (x mod 10)=0 then
  754.             plotchar(x,1,((x div 10) mod 10)+ord('0'));
  755.         end;
  756.         hig:=mem[0:$484];
  757.         for x:=0 to hig do
  758.         begin
  759.           plotchar(0,x,(x mod 10)+ord('0'));
  760.           if (x mod 10)=0 then
  761.             plotchar(1,x,((x div 10) mod 10)+ord('0'));
  762.         end;
  763.         plotstr(5,5,'Testing mode '+hex2(md)+'h: '+istr(wid)+'x'+istr(hig+1));
  764.         for x:=0 to 255 do
  765.           plotchat(x and 15+10,x shr 4+7,65,x);
  766.         if readkey='' then;
  767.         x:=x;
  768.       end;
  769.     end;
  770.   end;
  771.   textmode(3);
  772. end;
  773.  
  774.  
  775.  
  776. procedure testvesamodes;          {Test VESA modes}
  777. type
  778.   modelist=array[1..100] of word;
  779. var
  780.   vesahrec:record
  781.              sign:longint;
  782.              version:word;
  783.              oemname:^char;
  784.              capabilities:longint;
  785.              list:^modelist;
  786.              xx:array[1..256] of byte;  {Might be filled by AX=4F00h}
  787.            end;
  788.   mode,x,y,novesamodes:word;
  789.   oldchip:chips;
  790.   c:char;
  791.  
  792. procedure tmode(m:word);
  793. begin
  794.   vesamodeinfo(m);
  795.   pixels :=vesarec.width;
  796.   lins   :=vesarec.height;
  797.   bytes  :=vesarec.bytes;
  798.   if setmode(m) then testvmode;
  799. end;
  800.  
  801.  
  802. begin
  803.   oldchip:=chip;
  804.   chip:=__vesa;
  805.   rp.es:=seg(vesahrec);
  806.   rp.di:=ofs(vesahrec);
  807.   vesahrec.sign:=$41534556;
  808.   vio($4f00);
  809.   mode:=1;
  810.  
  811.      {S3 VESA driver can return wrong segment if run with QEMM}
  812.   IF {(oldchip=__s3) and} (seg(vesahrec.list^)=$e000) then
  813.     vesahrec.list:=ptr($c000,ofs(vesahrec.list^));
  814.   textmode($103);
  815.   writeln('Modes:');
  816.   writeln;
  817.   while vesahrec.list^[mode]<>$ffff do
  818.   begin
  819.     vesamodeinfo(vesahrec.list^[mode]);
  820.     writeln('  '+chr(mode+64)+' '+hex4(vesahrec.list^[mode])+'h '
  821.            +istr(vesarec.width)+'x'+istr(vesarec.height)+' '
  822.            +mdtxt[memmode]);
  823.  
  824.     inc(mode);
  825.   end;
  826.   novesamodes:=mode;
  827.   writeln;
  828.   writeln('  *  All modes');
  829.  
  830.   writeln;
  831.   c:=upcase(readkey);
  832.   for mode:=1 to novesamodes do
  833.     if (c='*') or (c=chr(mode+64)) then
  834.       tmode(vesahrec.list^[mode]);
  835.   chip:=oldchip;
  836.   textmode(3);
  837.   clrscr;
  838. end;
  839.  
  840.  
  841. var
  842.   stop:boolean;
  843.  
  844.  
  845. procedure loadmodes;              {Load extended modes for this chip}
  846. var
  847.   t:text;
  848.   s,pat:string;
  849.   md,x,xres,yres,err,mreq,byt:word;
  850.  
  851.  
  852. function unhex(s:string):word;
  853. var x:word;
  854. begin
  855.   for x:=1 to 4 do
  856.     if s[x]>'9' then
  857.       s[x]:=chr(ord(s[x]) and $5f-7);
  858.   unhex:=(((word(ord(s[1])-48) shl 4
  859.          +  word(ord(s[2])-48)) shl 4
  860.          +  word(ord(s[3])-48)) shl 4
  861.          +  word(ord(s[4])-48));
  862. end;
  863.  
  864. function mmode(s:string):mmods;
  865. var x:mmods;
  866. begin
  867.   for x:=_text to _p16m do
  868.     if s=mmodenames[x] then mmode:=x;
  869.  
  870. end;
  871.  
  872. begin
  873.   nomodes:=0;
  874.   pat:='['+header[chip]+']';
  875.   assign(t,'whatvga.lst');
  876.   reset(t);
  877.   s:=' ';
  878.   while (not eof(t)) and (s<>pat) do readln(t,s);
  879.   s:=' ';
  880.   readln(t,s);
  881.   while (s[1]<>'[') and (s<>'') do
  882.   begin
  883.     md:=unhex(copy(s,1,4));
  884.     memmode:=mmode(copy(s,6,4));
  885.     val(copy(s,11,5),xres,err);
  886.     val(copy(s,17,4),yres,err);
  887.     case memmode of
  888.       _text,_text4:bytes:=xres*2;
  889.  _pl2e, _herc,_cga2,_pl2:bytes:=xres shr 3;
  890.     _pk4,_pl4,_cga4:bytes:=xres shr 4;
  891.        _pl16,_pk16:bytes:=xres shr 1;
  892.              _p256:bytes:=xres;
  893.        _p32k,_p64k:bytes:=xres*2;
  894.              _p16m:bytes:=xres*3;
  895.     else
  896.     end;
  897.     case dactype of
  898.         _dac8:if memmode>_p256 then memmode:=_text;
  899.        _dac15:if memmode>_p32k then memmode:=_text;
  900.        _dac16:if memmode=_p16m then memmode:=_text;
  901.      _dacss24:if memmode=_p64k then memmode:=_text;
  902.     end;
  903.     val(copy(s,22,5),byt,err);
  904.     if (err=0) and (byt>0) then bytes:=byt;
  905.     if err<>0 then mreq:=(longint(bytes)*yres+1023) div 1024;
  906.     case memmode of
  907.       _pl16:bytes:=xres shr 3;
  908.     end;
  909.     if (memmode>_text4) and (mm>=mreq) then
  910.     begin
  911.       inc(nomodes);
  912.       modetbl[nomodes].xres:=xres;
  913.       modetbl[nomodes].yres:=yres;
  914.       modetbl[nomodes].md:=md;
  915.       modetbl[nomodes].bytes:=bytes;
  916.       modetbl[nomodes].memmode:=memmode;
  917.     end;
  918.     readln(t,s);
  919.   end;
  920.   close(t);
  921. end;
  922.  
  923.  
  924. var
  925.   chp,force_chip:chips;
  926.   s:string;
  927.   force_mm:word;
  928.   err,x:word;
  929.  
  930.  
  931. begin
  932.   fillchar(dotest,sizeof(dotest),ord(true));   {allow test for all chips}
  933.   force_mm:=0;
  934.   force_chip:=__none;
  935.   for x:=1 to paramcount do
  936.   begin
  937.     s:=paramstr(x);
  938.     case s[1] of
  939.      '-':begin
  940.            s:=upstr(strip(copy(s,2,255)));
  941.            for chp:=chips(1) to __none do
  942.              if upstr(header[chp])=s then
  943.                dotest[chp]:=false;
  944.          end;
  945.      '+':begin
  946.            s:=upstr(strip(copy(s,2,255)));
  947.            fillchar(dotest,sizeof(dotest),ord(false));
  948.            for chp:=chips(1) to __none do
  949.              if upstr(header[chp])=s then
  950.              begin
  951.                dotest[chp]:=true;
  952.                force_chip:=chp;
  953.              end;
  954.          end;
  955.      '=':val(copy(s,2,255),force_mm,err);
  956.     end;
  957.   end;
  958.  
  959.   findvideo;
  960.  
  961.   if force_chip<>__none then chip:=force_chip;
  962.   if force_mm<>0 then mm:=force_mm;
  963.  
  964.   loadmodes;
  965.  
  966.  
  967.  
  968.   stop:=false;
  969.   repeat
  970.     textmode(3);
  971.     writeln('WHATVGA v. 1.0    23/jan/93    Copyright 1991,92,93  Finn Thoegersen');
  972.     writeln;
  973.  
  974.     write('Video system: ',video,' with '+istr(mm)+' Kbytes.');
  975.     if _crt<>'' then write(' Monitor: '+_crt);
  976.     writeln;
  977.     if secondary<>'' then writeln('Secondary display: '+secondary);
  978.     Write('Chipset: '+header[chip]);
  979.     if name<>'' then write('  Name: '+name);
  980.     writeln;
  981.     if extra<>'' then writeln(extra);
  982.     writeln('Dac: '+dacname);
  983.  
  984.     writeln;
  985.     writeln('     1  Test Standard VGA modes');
  986.     writeln('     2  Test Extended VGA modes');
  987.     writeln('     3  Test scroll function');
  988.     writeln('     4  Search for video modes');
  989.     if vesa<>0 then
  990.       writeln('     5  Test VESA modes.');
  991.     writeln('     9  Stop');
  992.     writeln;
  993.     case readkey of
  994.       '1':teststdvgamodes;
  995.       '2':testvgamodes;
  996.       '3':testscrollmodes;
  997.       '4':searchformodes;
  998.       '5':if vesa<>0 then testvesamodes;
  999.  
  1000.       '9':stop:=true;
  1001.     end;
  1002.  
  1003.   until stop;
  1004.  
  1005.  
  1006.   vio(3);
  1007. end.